home *** CD-ROM | disk | FTP | other *** search
/ MacFormat 1994 November / macformat-018.iso / Utility Spectacular / Developer / macgambit-20-compiler-src-p2 / Interp⁄Comp (.scm) / utils.scm < prev   
Encoding:
Text File  |  1994-07-26  |  7.7 KB  |  267 lines  |  [TEXT/gamI]
  1. ;==============================================================================
  2.  
  3. ; file: "utils.scm"
  4.  
  5. ;------------------------------------------------------------------------------
  6. ;
  7. ; Utilities:
  8. ; ---------
  9.  
  10. (define (make-counter limit limit-error)
  11.   (let ((count 0))
  12.     (lambda ()
  13.       (if (< count limit)
  14.         (begin (set! count (+ count 1)) count)
  15.         (limit-error)))))
  16.  
  17. (define (pos-in-list x l)
  18.   (let loop ((l l) (i 0))
  19.     (cond ((not (pair? l)) #f)
  20.           ((eq? (car l) x) i)
  21.           (else            (loop (cdr l) (+ i 1))))))
  22.  
  23. (define (string-pos-in-list x l)
  24.   (let loop ((l l) (i 0))
  25.     (cond ((not (pair? l))      #f)
  26.           ((string=? (car l) x) i)
  27.           (else                 (loop (cdr l) (+ i 1))))))
  28.  
  29. (define (nth-after l n)
  30.   (let loop ((l l) (n n))
  31.     (if (> n 0)
  32.       (loop (cdr l) (- n 1))
  33.       l)))
  34.  
  35. (define (pair-up l1 l2)
  36.   (define (pair l1 l2)
  37.     (if (pair? l1)
  38.       (cons (cons (car l1) (car l2)) (pair (cdr l1) (cdr l2)))
  39.       '()))
  40.   (pair l1 l2))
  41.  
  42. (define (sort-list l <?)
  43.  
  44.   (define (mergesort l)
  45.  
  46.     (define (merge l1 l2)
  47.       (cond ((null? l1) l2)
  48.             ((null? l2) l1)
  49.             (else
  50.              (let ((e1 (car l1)) (e2 (car l2)))
  51.                (if (<? e1 e2)
  52.                  (cons e1 (merge (cdr l1) l2))
  53.                  (cons e2 (merge l1 (cdr l2))))))))
  54.  
  55.     (define (split l)
  56.       (if (or (null? l) (null? (cdr l)))
  57.         l
  58.         (cons (car l) (split (cddr l)))))
  59.  
  60.     (if (or (null? l) (null? (cdr l)))
  61.       l
  62.       (let* ((l1 (mergesort (split l)))
  63.              (l2 (mergesort (split (cdr l)))))
  64.         (merge l1 l2))))
  65.  
  66.   (mergesort l))
  67.  
  68. (define (lst->vector l)
  69.   (let* ((n (length l))
  70.          (v (make-vector n)))
  71.     (let loop ((l l) (i 0))
  72.       (if (pair? l)
  73.         (begin
  74.           (vector-set! v i (car l))
  75.           (loop (cdr l) (+ i 1)))
  76.         v))))
  77.  
  78. (define (vector->lst v)
  79.   (let loop ((l '()) (i (- (vector-length v) 1)))
  80.     (if (< i 0)
  81.       l
  82.       (loop (cons (vector-ref v i) l) (- i 1)))))
  83.  
  84. (define (lst->string l)
  85.   (let* ((n (length l))
  86.          (s (make-string n)))
  87.     (let loop ((l l) (i 0))
  88.       (if (pair? l)
  89.         (begin
  90.           (string-set! s i (car l))
  91.           (loop (cdr l) (+ i 1)))
  92.         s))))
  93.  
  94. (define (string->lst s)
  95.   (let loop ((l '()) (i (- (string-length s) 1)))
  96.     (if (< i 0)
  97.       l
  98.       (loop (cons (string-ref s i) l) (- i 1)))))
  99.  
  100. ;------------------------------------------------------------------------------
  101. ;
  102. ; Exception processing
  103. ; --------------------
  104.  
  105. (define (with-exception-handling proc)
  106.   (let ((old-exception-handler throw-to-exception-handler))
  107.     (let ((val
  108.             (call-with-current-continuation
  109.               (lambda (cont)
  110.                 (set! throw-to-exception-handler cont)
  111.                 (proc)))))
  112.     (set! throw-to-exception-handler old-exception-handler)
  113.     val)))
  114.  
  115. (define (throw-to-exception-handler val)
  116.   (fatal-err "*** Internal error, no exception handler at this point" val))
  117.  
  118. ;------------------------------------------------------------------------------
  119. ;
  120. ; Compiler warnings and error messaging
  121. ; -------------------------------------
  122.  
  123. (define (compiler-warning msg . args)
  124.   (newline)
  125.   (display "*** Warning: ") (display msg)
  126.   (for-each (lambda (x) (display " ") (write x)) args)
  127.   (newline))
  128.  
  129. (define (compiler-error msg . args)
  130.   (newline)
  131.   (display "*** Error: ")
  132.   (display msg)
  133.   (for-each (lambda (x) (display " ") (write x)) args)
  134.   (newline)
  135.   (compiler-abort))
  136.  
  137. (define (compiler-user-error loc msg . args)
  138.   (newline)
  139.   (display "*** User error detected") (locat-show loc) (newline)
  140.   (display "*** ") (display msg)
  141.   (for-each (lambda (x) (display " ") (write x)) args)
  142.   (newline)
  143.   (compiler-abort))
  144.  
  145. (define (compiler-internal-error msg . args)
  146.   (newline)
  147.   (display "*** Internal error detected") (newline)
  148.   (display "*** in procedure ") (display msg)
  149.   (for-each (lambda (x) (display " ") (write x)) args)
  150.   (newline)
  151.   (compiler-abort))
  152.  
  153. (define (compiler-limitation-error msg . args)
  154.   (newline)
  155.   (display "*** Compiler limit reached") (newline)
  156.   (display "*** ") (display msg)
  157.   (for-each (lambda (x) (display " ") (write x)) args)
  158.   (newline)
  159.   (compiler-abort))
  160.  
  161. (define (compiler-abort)
  162.   (display "*** Aborting compilation") (newline)
  163.   (throw-to-exception-handler #f))
  164.  
  165. ;------------------------------------------------------------------------------
  166. ;
  167. ; SET manipulation stuff
  168. ; ----------------------
  169.  
  170. (define (list->set list)    list)         ; convert list to set
  171. (define (set->list set)     set)          ; convert set to list
  172. (define (set-empty)         '())          ; the empty set
  173. (define (set-empty? set)    (null? set))  ; is 'x' the empty set?
  174. (define (set-member? x set) (memq x set)) ; is 'x' a member of the 'set'?
  175. (define (set-singleton x)   (list x))     ; create a set containing only 'x'
  176.  
  177. (define (set-adjoin set x)                ; add the element 'x' to the 'set'
  178.   (if (memq x set) set (cons x set)))
  179.  
  180. (define (set-remove set x)                ; remove the element 'x' from 'set'
  181.   (cond ((null? set)       '())
  182.         ((eq? (car set) x) (cdr set))
  183.         (else              (cons (car set) (set-remove (cdr set) x)))))
  184.  
  185. (define (set-equal? s1 s2)
  186.   (cond ((null? s1)         (null? s2))
  187.         ((memq (car s1) s2) (set-equal? (cdr s1) (set-remove s2 (car s1))))
  188.         (else               #f)))
  189.  
  190. (define (set-difference set . other-sets) ; return difference of sets
  191.   (define (difference s1 s2)
  192.     (cond ((null? s1)         '())
  193.           ((memq (car s1) s2) (difference (cdr s1) s2))
  194.           (else               (cons (car s1) (difference (cdr s1) s2)))))
  195.   (n-ary difference set other-sets))
  196.  
  197. (define (set-union . sets)                ; return union of sets
  198.   (define (union s1 s2)
  199.     (cond ((null? s1)         s2)
  200.           ((memq (car s1) s2) (union (cdr s1) s2))
  201.           (else               (cons (car s1) (union (cdr s1) s2)))))
  202.   (n-ary union '() sets))
  203.  
  204. (define (set-intersection set . other-sets) ; return intersection of sets
  205.   (define (intersection s1 s2)
  206.     (cond ((null? s1)         '())
  207.           ((memq (car s1) s2) (cons (car s1) (intersection (cdr s1) s2)))
  208.           (else               (intersection (cdr s1) s2))))
  209.   (n-ary intersection set other-sets))
  210.  
  211. (define (n-ary function first rest)
  212.   (if (null? rest)
  213.     first
  214.     (n-ary function (function first (car rest)) (cdr rest))))
  215.  
  216. (define (set-keep keep? set)
  217.   (cond ((null? set)       '())
  218.         ((keep? (car set)) (cons (car set) (set-keep keep? (cdr set))))
  219.         (else              (set-keep keep? (cdr set)))))
  220.  
  221. (define (set-every? pred? set)
  222.   (or (null? set)
  223.       (and (pred? (car set))
  224.            (set-every? pred? (cdr set)))))
  225.  
  226. (define (set-map proc set)
  227.   (if (null? set)
  228.     '()
  229.     (cons (proc (car set)) (set-map proc (cdr set)))))
  230.  
  231. ;------------------------------------------------------------------------------
  232. ;
  233. ; QUEUE manipulation stuff
  234. ; ------------------------
  235.  
  236. (define (list->queue list)    ; convert list to queue
  237.   (define (last-pair l)
  238.     (if (pair? (cdr l)) (last-pair (cdr l)) l))
  239.   (cons list (if (pair? list) (last-pair list) '())))
  240.  
  241. (define (queue->list queue)   ; convert queue to list
  242.   (car queue))
  243.  
  244. (define (queue-empty)         ; the empty queue
  245.   (cons '() '()))
  246.  
  247. (define (queue-empty? queue)  ; is the queue empty?
  248.   (null? (car queue)))
  249.  
  250. (define (queue-get! queue)    ; remove the first element of the queue
  251.   (if (null? (car queue))
  252.     (compiler-internal-error "queue-get!, queue is empty")
  253.     (let ((x (caar queue)))
  254.       (set-car! queue (cdar queue))
  255.       (if (null? (car queue)) (set-cdr! queue '()))
  256.       x)))
  257.  
  258. (define (queue-put! queue x)  ; add an element to the end of the queue
  259.   (let ((entry (cons x '())))
  260.     (if (null? (car queue))
  261.       (set-car! queue entry)
  262.       (set-cdr! (cdr queue) entry))
  263.     (set-cdr! queue entry)
  264.     x))
  265.  
  266. ;==============================================================================
  267.